home *** CD-ROM | disk | FTP | other *** search
/ Netware Super Library / Netware Super Library.iso / mis_util / dbfdir / dbfdir.prg < prev   
Text File  |  1995-06-30  |  15KB  |  442 lines
  1. *!*********************************************************************
  2. *!
  3. *!    Source File: DBFDIR.PRG
  4. *!
  5. *!         System: DBFDIR - Database directory
  6. *!         Author: John Wright
  7. *!   Copyright (c) 1993-1995 John Wright
  8. *!
  9. *!        Procedures : Force_main
  10. *!
  11. *!*********************************************************************
  12. * 07/20/93 - Modified DISPSTRU to emulate old DBDIR.COM with added
  13. *            support for FoxPro DBFs.
  14. * 10/07/93 - Added support for dBase II files.
  15. * 11/15/93 - Display DBF structure if /S specified.
  16. * 11/16/93 - Check for FoxPro CDX reference.
  17. * 02/06/94 - Changed to work with Force 2.4 new features/syntax.
  18. * 06/30/95 - Better support for dBASE II files including structure list.
  19. *            Some old programs still use dBASE II files!!!
  20.  
  21. #INCLUDE date.hdr
  22. #INCLUDE fileio.hdr
  23. #INCLUDE string.hdr
  24. #INCLUDE system.hdr
  25. #INCLUDE io.hdr
  26.  
  27. #PRAGMA w_func_proc-
  28.  
  29. *!**********************************************
  30. *!
  31. *!                   Procedure Force_main
  32. *!
  33. *!Parameters : Type      Method    Name
  34. *!           : CHAR(127) REFERENCE cmd_line
  35. *!
  36. *!**********************************************
  37. PROCEDURE Force_main
  38.    PARAMETERS CHAR(127) cmd_line
  39.  
  40.    VARDEF
  41.       CHAR      cr_lf
  42.       CHAR      cPattern
  43.       CHAR      cDbfPath
  44.       CHAR      cDbfName
  45.       CHAR      cText
  46.       CHAR(1)   cVersion
  47.       CHAR(3)   cLastUpdate
  48.       CHAR(1)   cField
  49.       CHAR(1)   cCDXbyte
  50.       * field info
  51.       CHAR(10)  fld_name
  52.       CHAR(1)   fld_type
  53.       CHAR(1)   fld_len
  54.       CHAR(1)   fld_dec
  55.       INT       nHeader
  56.       INT       nFields
  57.       INT       nRecSize
  58.       INT       nLoop
  59.       INT       nSpot
  60.       LONG      nRecs
  61.       UINT      uHandle
  62.       UINT      nError
  63.       LOGICAL   lStructure
  64.    ENDDEF
  65.  
  66.    cPattern := cmd_line
  67.    cr_lf    := CHR(13)+CHR(10)
  68.  
  69.    cText := "DBFDIR v1.4 - Database Directory                 "+;
  70.             "(c) 1993-1995 John Wright"+cr_lf
  71.    FB_WRITE(&STD_OUT,cText,LEN(cText))
  72.    FB_WRITE(&STD_OUT,cr_lf,2)
  73.  
  74.    IF "/?" $ cPattern
  75.       cText := "Display a DBF directory list or file structures."+cr_lf
  76.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  77.       cText := " "+cr_lf
  78.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  79.       cText := "Syntax: DBFDIR [<pattern>] [/S] "+cr_lf
  80.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  81.       cText := " "+cr_lf
  82.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  83.       cText := " Start  Size   Contents of DBF header"+cr_lf
  84.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  85.       cText := " -----  ----   ----------------------"+cr_lf
  86.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  87.       cText := "    0      1   Database version (see list below)"+cr_lf
  88.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  89.       cText := "    1      3   Date of last update"+cr_lf
  90.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  91.       cText := "    4      4   Last record (number of records)"+cr_lf
  92.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  93.       cText := "    8      2   Offset where data starts"+cr_lf
  94.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  95.       cText := "    9      2   Record size"+cr_lf
  96.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  97.       cText := "   11     20   Filler "+;
  98.                "(FoxPro DBFs may contain CDX reference)"+cr_lf
  99.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  100.       cText := " "+cr_lf
  101.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  102.       cText := "         DEC   File type                HEX"+cr_lf
  103.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  104.       cText := "         ---   ---------------------    ---"+cr_lf
  105.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  106.       cText := "          02   dBASE II                  02"+cr_lf
  107.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  108.       cText := " Valid:   03   dBASE III/Clipper/Fox     03"+cr_lf
  109.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  110.       cText := "  DBF     04   dBASE IV                  04"+cr_lf
  111.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  112.       cText := "  ver.   131   dBASE III with Memos      83"+cr_lf
  113.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  114.       cText := "         139   dBASE IV  with Memos      8B"+cr_lf
  115.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  116.       cText := "         245   FoxPro    with Memos      F5"+cr_lf
  117.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  118.       QUIT
  119.    ENDIF
  120.  
  121.    cPattern := UPPER(LTRIM(RTRIM(cPattern))) + " "
  122.  
  123.    IF "/S" $ cPattern
  124.       lStructure := .T.
  125.       nLoop := AT( "/S", cPattern )
  126.       cText := SUBSTR( cPattern, 1, nLoop-1 )
  127.       cText += SUBSTR( cPattern, nLoop+2, LEN(cPattern)-2 )
  128.       cPattern := LTRIM(cText)
  129.    ELSE
  130.       lStructure := .F.
  131.    ENDIF
  132.  
  133.    IF cPattern := " "
  134.       cPattern := "*.DBF"
  135.    ENDIF
  136.  
  137.    * Save path if specified (FIND_FSTR only returns the file name)
  138.    DO CASE
  139.    CASE "\" $ cPattern
  140.       cDbfPath := UPPER(SUBSTR(cPattern,1,RAT("\",cPattern)))
  141.    CASE ":" $ cPattern
  142.       cDbfPath := UPPER(SUBSTR(cPattern,1,RAT(":",cPattern)))
  143.    OTHERWISE
  144.       cDbfPath := ""
  145.    ENDCASE
  146.  
  147.    * search for matching file(s)
  148.    IF .NOT. FIND_FIRST( cPattern, 0x20 )
  149.       cText := "ERROR:  No files found matching => "+cPattern+cr_lf
  150.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  151.       FB_WRITE(&STD_OUT,cr_lf,2)
  152.       QUIT
  153.    ENDIF
  154.  
  155.    IF .NOT. lStructure
  156.       cText := "Database name    Records  Last Update  Filesize  "
  157.       cText += "RecLen  Fields  Memo  Ver"+cr_lf
  158.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  159.    ENDIF
  160.  
  161.    REPEAT
  162.  
  163.       * Reset counters and flags
  164.       cVersion := " "
  165.       cCDXbyte := " "
  166.       nFields  := 0
  167.       nHeader  := 0
  168.       nRecSize := 0
  169.       nRecs    := 0
  170.  
  171.       cDbfName := cDbfPath+FIND_FSTR()
  172.  
  173.       IF .NOT. FB_OPEN( uHandle, cDbfName, &B_READ )
  174.          cText := "ERROR:  Cannot open file => "+cDbfName+cr_lf
  175.          FB_WRITE(&STD_OUT,cText,LEN(cText))
  176.          LOOP
  177.       ELSE
  178.          cText := SUBSTR( FIND_FSTR() + SPACE(12), 1, 12 )
  179.       ENDIF
  180.  
  181.       * Look for CDX reference
  182.       FB_SEEK(uHandle,28,&FB_BEGIN)
  183.       FB_READ(uHandle,cCDXbyte,1)
  184.  
  185.       * Get the database version - first character
  186.       FB_SEEK(uHandle,0,&FB_BEGIN)
  187.       FB_READ(uHandle,cVersion,1)
  188.  
  189.       IF cVersion $ "âï⌡"
  190.  
  191.          * dBase III compatible file
  192.          IF cVersion <> ""
  193.             * Date of last update stored as three digit character string
  194.             FB_SEEK(uHandle,1,&FB_BEGIN)
  195.             FB_READ(uHandle,cLastUpdate,3)
  196.  
  197.             * Number of records stored as four digit binary number
  198.             FB_SEEK( uHandle, 4, &FB_BEGIN )
  199.             FB_READ( uHandle, nRecs, 4 )
  200.  
  201.             * Header size
  202.             FB_SEEK( uHandle, 8, &FB_BEGIN )
  203.             FB_READ( uHandle, nHeader, 2 )
  204.  
  205.             * Header prologue is 33 and fields are 32 each
  206.             nFields := ( nHeader - 33 ) / 32
  207.  
  208.             * Record size
  209.             FB_SEEK( uHandle, 10, &FB_BEGIN )
  210.             FB_READ( uHandle, nRecSize, 2 )
  211.  
  212.             IF lStructure
  213.  
  214.                cText := "Name of database file: "+FIND_FSTR()+cr_lf
  215.                FB_WRITE(&STD_OUT,cText,LEN(cText))
  216.  
  217.                cText := "Number of records:     "+;
  218.                   LTRIM(STR( nRecs, 12, 0 )) + cr_lf
  219.                FB_WRITE(&STD_OUT,cText,LEN(cText))
  220.  
  221.                cText := "Date of last update:   "+;
  222.                RIGHT("00"+LTRIM(STR(ASC(SUBSTR(cLastUpdate,2,1)),2,0)),2)+"/"+;
  223.                RIGHT("00"+LTRIM(STR(ASC(SUBSTR(cLastUpdate,3,1)),2,0)),2)+"/"+;
  224.                STR(ASC(SUBSTR(cLastUpdate,1,1)),2,0) + cr_lf
  225.                FB_WRITE(&STD_OUT,cText,LEN(cText))
  226.  
  227.                IF cCDXbyte = ""
  228.                   cText := "CDX reference found!" + cr_lf
  229.                   FB_WRITE(&STD_OUT,cText,LEN(cText))
  230.                ENDIF
  231.  
  232.                cText := "Field  Field name  Type        Width   Dec"+cr_lf
  233.                FB_WRITE(&STD_OUT,cText,LEN(cText))
  234.  
  235.                * process the DBF header
  236.                fld_name := " "
  237.                FOR nLoop := 1 TO nFields
  238.                   nSpot :=  (nLoop*32)
  239.                   FB_SEEK(uHandle,nSpot,&FB_BEGIN)
  240.  
  241.                   * get field name and check first character
  242.                   FB_READ(uHandle,fld_name,10)
  243.  
  244.                   * CHR(13) means end of field definitions
  245.                   IF SUBSTR(fld_name,1,1) <> CHR(13)
  246.  
  247.                      * Gobble up an extra character ...
  248.                      FB_READ(uHandle,fld_type,1)
  249.  
  250.                      * field type  -  11th position
  251.                      FB_READ(uHandle,fld_type,1)
  252.                      fld_type := SUBSTR(fld_type,1,1)
  253.  
  254.                      * field length - 16th position
  255.                      nSpot := (nLoop*32)+16
  256.                      FB_SEEK(uHandle,nSpot,&FB_BEGIN)
  257.                      FB_READ(uHandle,fld_len,1)
  258.  
  259.                      * field decimal - 17th position
  260.                      FB_READ(uHandle,fld_dec,1)
  261.  
  262.                      * print the field and continue
  263.                      cText := STR(nLoop,5,0)+"  "+;
  264.                         SUBSTR(fld_name+SPACE(12),1,12)
  265.                      DO CASE
  266.                      CASE fld_type = "C"
  267.                         cText += "Character"
  268.                      CASE fld_type = "D"
  269.                         cText += "Date     "
  270.                      CASE fld_type = "L"
  271.                         cText += "Logical  "
  272.                      CASE fld_type = "M"
  273.                         cText += "Memo     "
  274.                      CASE fld_type = "N"
  275.                         cText += "Numeric  "
  276.                      OTHERWISE
  277.                         cText += "unknown  "
  278.                      ENDCASE
  279.                      cText += STR(ASC(fld_len),8,0)
  280.                      IF fld_type = "N"
  281.                         cText += STR(ASC(fld_dec),6,0)
  282.                      ENDIF
  283.                      IF fld_type = "M"
  284.                         * Type of memo
  285.                         DO CASE
  286.                         CASE cVersion $ "â"
  287.                            cText += "   DB3"
  288.                         CASE cVersion $ "ï"
  289.                            cText += "   DB4"
  290.                         CASE cVersion $ "⌡"
  291.                            cText += "   Fox"
  292.                         ENDCASE
  293.                      ENDIF
  294.                      cText += cr_lf
  295.                      FB_WRITE(&STD_OUT,cText,LEN(cText))
  296.                   ENDIF
  297.                NEXT
  298.                cText := "** Total **"+STR(nRecSize,25,0)+cr_lf
  299.             ELSE
  300.                cText += STR( nRecs, 12, 0 )
  301.                cText += "   "+;
  302.                RIGHT("00"+LTRIM(STR(ASC(SUBSTR(cLastUpdate,2,1)),2,0)),2)+"/"+;
  303.                RIGHT("00"+LTRIM(STR(ASC(SUBSTR(cLastUpdate,3,1)),2,0)),2)+"/"+;
  304.                STR(ASC(SUBSTR(cLastUpdate,1,1)),2,0)
  305.             ENDIF
  306.          ELSE
  307.  
  308.             * Number of records in dBASE II header
  309.             FB_SEEK( uHandle, 1, &FB_BEGIN )
  310.             FB_READ( uHandle, nRecs, 2 )
  311.             cText += STR( nRecs, 12, 0 )
  312.  
  313.             * Record size
  314.             FB_SEEK( uHandle, 6, &FB_BEGIN )
  315.             FB_READ( uHandle, nRecSize, 1 )
  316.  
  317.             * dBase II file structure is different...
  318.             IF lStructure
  319.                cText := "Name of database file: "+FIND_FSTR()+cr_lf
  320.                FB_WRITE(&STD_OUT,cText,LEN(cText))
  321.                cText := "Number of records:     "+;
  322.                   LTRIM(STR( nRecs, 12, 0 ))+cr_lf
  323.                FB_WRITE(&STD_OUT,cText,LEN(cText))
  324.                cText := "Field  Field name  Type        Width   Dec"+cr_lf
  325.                FB_WRITE(&STD_OUT,cText,LEN(cText))
  326.             ELSE
  327.                * Don't know last update for dBase II files
  328.                cText += "   " + DTOC( FIND_FDATE() )
  329.             ENDIF
  330.  
  331.             * Figure out the number of fields (max = 32)
  332.             nFields := 0
  333.             FOR nLoop := 1 TO 32
  334.  
  335.                * Position to field start
  336.                nSpot := 8 + ( (nLoop-1) * 16 )
  337.                FB_SEEK(uHandle,nSpot,&FB_BEGIN)
  338.  
  339.                * Read field name
  340.                FB_READ(uHandle,fld_name,10)
  341.  
  342.                * Check if a valid field name
  343.                IF AT( SUBSTR(fld_name,1,1), CHR(13)+CHR(0) ) > 0
  344.                   EXIT
  345.                ELSE
  346.                   nFields ++
  347.                ENDIF
  348.  
  349.                IF lStructure
  350.                   * print field and continue
  351.                   cText := STR(nFields,5,0)+"  "
  352.                   cText += SUBSTR(fld_name+SPACE(12),1,12)
  353.  
  354.                   * Gobble up an extra character ...
  355.                   FB_READ(uHandle,fld_type,1)
  356.  
  357.                   * Read field type
  358.                   FB_READ(uHandle,fld_type,1)
  359.                   DO CASE
  360.                   CASE fld_type = "C"
  361.                      cText += "Character"
  362.                   CASE fld_type = "D"
  363.                      cText += "Date     "
  364.                   CASE fld_type = "L"
  365.                      cText += "Logical  "
  366.                   CASE fld_type = "M"
  367.                      cText += "Memo     "
  368.                   CASE fld_type = "N"
  369.                      cText += "Numeric  "
  370.                   OTHERWISE
  371.                      cText += "unknown  "
  372.                   ENDCASE
  373.  
  374.                   * field length
  375.                   FB_READ(uHandle,fld_len,1)
  376.                   cText += STR(ASC(fld_len),8,0)
  377.  
  378.                   * field decimal (?)
  379.                   FB_READ(uHandle,fld_dec,1)
  380.                   IF fld_type = "N"
  381.                      cText += STR(ASC(fld_dec),6,0)
  382.                   ENDIF
  383.                   cText += cr_lf
  384.                   FB_WRITE(&STD_OUT,cText,LEN(cText))
  385.  
  386.                   cText := "** Total **"+STR(nRecSize,25,0)+cr_lf
  387.                ENDIF
  388.  
  389.             NEXT
  390.  
  391.          ENDIF
  392.  
  393.          IF .NOT. lStructure
  394.  
  395.             * File size
  396.             cText += STR( FIND_FSIZE(), 12, 0 )
  397.  
  398.             * Record size
  399.             cText += STR( nRecSize, 8, 0 )
  400.  
  401.             * Number of fields
  402.             cText += STR( nFields, 8, 0 ) + "   "
  403.  
  404.             * Does file have memo fields?
  405.             IF cVersion $ "âï⌡"
  406.                cText += "Yes  "
  407.             ELSE
  408.                cText += "No   "
  409.             ENDIF
  410.  
  411.             * Type of file
  412.             DO CASE
  413.             CASE cVersion $ ""
  414.                cText += "dB2"
  415.             CASE cVersion $ "â"
  416.                cText += "dB3"
  417.             CASE cVersion $ "ï"
  418.                cText += "dB4"
  419.             CASE cVersion $ "⌡"
  420.                cText += "Fox"
  421.             ENDCASE
  422.             IF cCDXbyte = ""
  423.                cText += "+CDX"
  424.             ENDIF
  425.          ENDIF
  426.  
  427.       ELSE
  428.          cText += "  ** Unrecognized database type **"
  429.       ENDIF
  430.  
  431.       FB_WRITE(&STD_OUT,cText,LEN(cText))
  432.       FB_WRITE(&STD_OUT,cr_lf,2)
  433.  
  434.       FB_CLOSE(uHandle)
  435.  
  436.    UNTIL .NOT. FIND_NEXT()
  437.  
  438.    QUIT
  439.  
  440. ENDPRO
  441.  
  442. *: EOF: DBFDIR.PRG